home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / C / Applications / SML⁄NJ 93+ / Documentation / examples / redblack.sml < prev    next >
Encoding:
Text File  |  1995-12-30  |  2.0 KB  |  75 lines  |  [TEXT/R*ch]
  1. (* redblack.sml *)
  2.  
  3. functor RedBlack(B : sig type key
  4.              val > : key*key->bool
  5.              end):
  6.         sig type tree
  7.         type key
  8.         val empty : tree
  9.         val insert : key * tree -> tree
  10.         val lookup : key * tree -> key
  11.         exception Notfound of key
  12.         end =
  13. struct
  14.  open B
  15.  datatype color = RED | BLACK
  16.  datatype tree = empty | tree of key * color * tree * tree
  17.  exception Notfound of key
  18.  
  19.  fun insert (key,t) =
  20.   let fun f empty = tree(key,RED,empty,empty)
  21.         | f (tree(k,BLACK,l,r)) =
  22.         if key>k
  23.         then case f r
  24.          of r as tree(rk,RED, rl as tree(rlk,RED,rll,rlr),rr) =>
  25.             (case l
  26.              of tree(lk,RED,ll,lr) =>
  27.                 tree(k,RED,tree(lk,BLACK,ll,lr),
  28.                        tree(rk,BLACK,rl,rr))
  29.               | _ => tree(rlk,BLACK,tree(k,RED,l,rll),
  30.                         tree(rk,RED,rlr,rr)))
  31.           | r as tree(rk,RED,rl, rr as tree(rrk,RED,rrl,rrr)) =>
  32.             (case l
  33.              of tree(lk,RED,ll,lr) =>
  34.                 tree(k,RED,tree(lk,BLACK,ll,lr),
  35.                        tree(rk,BLACK,rl,rr))
  36.               | _ => tree(rk,BLACK,tree(k,RED,l,rl),rr))
  37.               | r => tree(k,BLACK,l,r)
  38.         else if k>key
  39.         then case f l
  40.              of l as tree(lk,RED,ll, lr as tree(lrk,RED,lrl,lrr)) =>
  41.             (case r
  42.              of tree(rk,RED,rl,rr) =>
  43.                 tree(k,RED,tree(lk,BLACK,ll,lr),
  44.                        tree(rk,BLACK,rl,rr))
  45.               | _ => tree(lrk,BLACK,tree(lk,RED,ll,lrl),
  46.                         tree(k,RED,lrr,r)))
  47.           | l as tree(lk,RED, ll as tree(llk,RED,lll,llr), lr) =>
  48.             (case r
  49.              of tree(rk,RED,rl,rr) =>
  50.                 tree(k,RED,tree(lk,BLACK,ll,lr),
  51.                        tree(rk,BLACK,rl,rr))
  52.               | _ => tree(lk,BLACK,ll,tree(k,RED,lr,r)))
  53.               | l => tree(k,BLACK,l,r)
  54.         else tree(key,BLACK,l,r)
  55.         | f (tree(k,RED,l,r)) =
  56.         if key>k then tree(k,RED,l, f r)
  57.         else if k>key then tree(k,RED, f l, r)
  58.         else tree(key,RED,l,r)
  59.    in case f t
  60.       of tree(k,RED, l as tree(_,RED,_,_), r) => tree(k,BLACK,l,r)
  61.        | tree(k,RED, l, r as tree(_,RED,_,_)) => tree(k,BLACK,l,r)
  62.        | t => t
  63.   end
  64.  
  65.  fun lookup (key,t) =
  66.   let fun look empty = raise (Notfound key)
  67.     | look (tree(k,_,l,r)) =
  68.         if k>key then look l
  69.         else if key>k then look r
  70.         else k
  71.    in look t
  72.   end
  73.  
  74. end
  75.